home *** CD-ROM | disk | FTP | other *** search
/ Trading on the Edge / Trading On The Edge - CD-ROM Toolkit (Wayzata Technology)(2031)(1994).bin / pc / mac_file / vendor_d / ga_softw / ooga / rep-meth.lis < prev    next >
File List  |  1991-02-03  |  15KB  |  461 lines
  1. ;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
  2. #||
  3.             RESTRICTED RIGHTS LEGEND
  4.                     
  5.  Use, duplication, or disclosure by the Government is subject to
  6.  restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  7.  Technical Data and Computer Software Clause at 52.227-7013 of the DOD
  8.  FAR Supplement.
  9.                     
  10.                 TSP (The Software Partnership)
  11.                 P.O. Box 991
  12.                 Melrose, MA 02176
  13.                     
  14.       Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
  15. ||#
  16.  
  17.  
  18. (in-package :ooga)
  19.  
  20.  
  21. ;;; This file contains methods contained in the reproduction
  22. ;;; module
  23.  
  24.  
  25.  
  26.  
  27. ;************************************************************
  28.  
  29. ;    OPERATOR SELECTION TECHNIQUE
  30.  
  31.  
  32. (defmethod INITIALIZE-FOR-RUN ((technique operator-selection-technique))
  33.   t)
  34.  
  35.  
  36. ;;; Operator selection techniques select operators for
  37. ;;; reproduction events.
  38.  
  39.  
  40. ;;; Use first operator uses the first operator on the list.  It
  41. ;;; shouldn't be used when there is more than one operator.
  42.  
  43. (defmethod GET-OPERATOR ((use-first-operator use-first-operator))
  44.   (first (operator-list (reproduction-module use-first-operator))))
  45.  
  46.  
  47. ;;; Roulette wheel operator selection chooses operators with
  48. ;;; probabilities biased by operator weights.
  49.  
  50. (defmethod GET-OPERATOR ((technique roulette-wheel-operator-selection))
  51.   (let ((reproduction-module (reproduction-module technique)))
  52.     (get-associated-total-list-element
  53.       (operator-list reproduction-module)
  54.       (operator-weights reproduction-module)
  55.       (random (apply '+ (operator-weights reproduction-module))))))
  56.  
  57.  
  58.  
  59. ;************************************************************
  60.  
  61. ;    REPRODUCTION PARAMETERIZATION TECHNIQUES
  62.  
  63.  
  64. ;;; Set the operator weights to their initial value.
  65.  
  66. (defmethod INITIALIZE-FOR-RUN ((technique interpolate-operator-weights))
  67.   (setf (operator-weights (reproduction-module technique))
  68.     (car (interpolation-specs technique))))
  69.  
  70.  
  71. ;;; Interpolate operator weights at given increments.
  72.  
  73. (defmethod MODIFY-PARAMETERS
  74.        ((technique interpolate-operator-weights)
  75.         portion-completed size-of-interval)
  76.   (if (even-multiple portion-completed (interpolation-interval technique))
  77.     (setf (operator-weights  (reproduction-module technique))
  78.       (interpolate-from-spec (car (interpolation-specs technique))
  79.                  (cadr (interpolation-specs technique))
  80.                  size-of-interval
  81.                  portion-completed))))
  82.  
  83.  
  84.  
  85. ;************************************************************
  86.  
  87. ;    REPRODUCTION MODULE
  88.  
  89.  
  90.  
  91. ;;; Drive the initialization of the module and its techniques.
  92.  
  93. (defmethod INITIALIZE-FOR-RUN
  94.        ((reproduction-module basic-reproduction-module))
  95.   (setf (reproduction-module (operator-selection-technique reproduction-module))
  96.     reproduction-module)
  97.   (loop for technique in (parameterization-techniques reproduction-module)
  98.     do (setf (reproduction-module technique) reproduction-module))
  99.   (loop for operator in (operator-list reproduction-module)
  100.     do (setf (reproduction-module operator) reproduction-module))
  101.   (initialize-for-run (operator-selection-technique reproduction-module))
  102.   (loop for technique in (parameterization-techniques reproduction-module)
  103.     do (initialize-for-run technique)))
  104.  
  105.  
  106. ;;; Create a new generation of population members.
  107.  
  108. (defmethod REPRODUCE ((reproduction-technique generational-replacement)
  109.               (reproduction-module basic-reproduction-module))
  110.   (loop with new-members = nil
  111.     with number-to-create = (population-size
  112.                   (population-module reproduction-technique))
  113.     until (>= (length new-members) number-to-create)
  114.     do (setf new-members
  115.          (append new-members
  116.              (create-new-members reproduction-module)))
  117.     finally (return (firstn number-to-create new-members))))
  118.  
  119.  
  120. ;;; As above, with elitism
  121.  
  122. (defmethod REPRODUCE ((reproduction-technique generational-replacement-with-elitism)
  123.               (reproduction-module basic-reproduction-module))
  124.   (loop with new-members = (list (first-member (population-module (ga reproduction-module))))
  125.     with number-to-create = (population-size
  126.                   (population-module reproduction-technique))
  127.     until (>= (length new-members) number-to-create)
  128.     do (setf new-members
  129.          (append new-members
  130.              (create-new-members reproduction-module)))
  131.     finally (return (firstn number-to-create new-members))))
  132.  
  133.  
  134.  
  135. ;;; Run one operator and return the children
  136.  
  137. (defmethod REPRODUCE ((reproduction-technique steady-state)
  138.               (reproduction-module basic-reproduction-module))
  139.   (create-new-members reproduction-module))
  140.  
  141.  
  142.  
  143. ;;; Create new members.  Only pass those back that are not
  144. ;;; duplicates of existing members.  Halt the run if too many
  145. ;;; duplicates have been produced.
  146.  
  147. (defmethod REPRODUCE ((reproduction-technique steady-state-without-duplicates)
  148.               (reproduction-module basic-reproduction-module))
  149.   (let* ((new-members (create-new-members reproduction-module))
  150.      (unduplicated-members
  151.        (loop for new-member-list on new-members
  152.          with population-module = (population-module
  153.                         (ga reproduction-module))
  154.          unless (or (loop for other-member in (cdr new-member-list)
  155.                   thereis (chromosome-equal
  156.                         (chromosome other-member)
  157.                         (chromosome (car new-member-list))))
  158.                 (chromosome-exists
  159.                   (car new-member-list) population-module))
  160.            collect (car new-member-list))))
  161.     (setf (duplicate-tally reproduction-technique)
  162.       (+ (duplicate-tally reproduction-technique)
  163.          (- (length new-members)
  164.         (length unduplicated-members))))
  165.     (if (< (duplicate-tally reproduction-technique)
  166.        (maximum-duplicates reproduction-technique))
  167.     unduplicated-members
  168.     (progn (setf (stop-run? (population-module (ga reproduction-module)))
  169.              (append (stop-run? (population-module
  170.                       (ga reproduction-module)))
  171.                  (list (format
  172.                      nil
  173.                      "MAXIMUM DUPLICATE NUMBER ~a EXCEEDED"
  174.                        (maximum-duplicates
  175.                          reproduction-technique)))))
  176.            nil)
  177.     )))
  178.  
  179.  
  180.  
  181. ;;; Apply an operator and return population members containing the
  182. ;;; resulting chromosomes.
  183.  
  184. (defmethod CREATE-NEW-MEMBERS
  185.        ((reproduction-module basic-reproduction-module))
  186.     (loop with population-module = (population-module
  187.                      (ga reproduction-module))
  188.           for chromosome in (apply-operator
  189.                   (get-operator
  190.                     (operator-selection-technique
  191.                       reproduction-module))
  192.                   population-module)
  193.           for new-member = (create-population-member
  194.                  (initialization-technique population-module)
  195.                  (representation-technique population-module))
  196.           collect (progn (setf (chromosome new-member) chromosome)
  197.                  new-member)))
  198.  
  199.  
  200. ;;; Does the chromosome already exist in the population?
  201.  
  202. (defmethod CHROMOSOME-EXISTS
  203.        ((member population-member)
  204.         (population-module basic-population-module))
  205.   (loop for existing-member = (first-member population-module)
  206.     then (successor existing-member)
  207.     until (null existing-member)
  208.     do (if (chromosome-equal
  209.          (chromosome member)
  210.          (chromosome existing-member))
  211.            (return t))
  212.     finally (return nil)))
  213.  
  214.  
  215. ;;;  REDEFINE THIS METHOD WHENEVER USING CHROMOSOMES 
  216. ;;;  THAT AREN'T LISTS
  217.  
  218. (defmethod CHROMOSOME-EQUAL ((chromosome1 t) (chromosome2 t))
  219.   (equal chromosome1 chromosome2))
  220.  
  221.  
  222. ;;;************************************************************
  223. ;;;************************************************************
  224.  
  225. ;;;    OPERATOR METHODS
  226.  
  227. ;;;************************************************************
  228. ;;;************************************************************
  229.  
  230.  
  231. ;NOTE THAT ALL OPERATORS SHOULD RETURN A LIST OF CHILDREN.
  232.  
  233. ;The message interface to operators is:  operators can call (get-parent optimizer)
  234. ;multiple times if needed.
  235.  
  236. ;Operators should return a list of children.  This list can be null.
  237.  
  238.  
  239.  
  240. (defgeneric APPLY-OPERATOR (operator basic-population-module)
  241.   #-:pcl
  242.   (:documentation "Apply OPERATOR to some apropriate portion of the population.
  243. This returns a list of new population members."))
  244.  
  245.  
  246.  
  247.  
  248. ;************************************************************
  249.  
  250. ;    ONE POINT CROSSOVER AND MUTATE
  251.  
  252.  
  253.  
  254. (defmethod APPLY-OPERATOR ((operator one-point-crossover-and-mutate)
  255.                (population-module basic-population-module))
  256.   "Cross two parents over at a single point to make two children"
  257.   (let* ((list1 (chromosome (get-parent population-module)))
  258.      (list2 (chromosome (get-parent population-module)))
  259.      (bit-mutation-rate (bit-mutation-rate operator)))
  260.     (if (probability-test (crossover-rate operator))
  261.     (loop for list in (one-point-crossover list1 list2)
  262.           collect (mutate-bits bit-mutation-rate list))
  263.     (list (mutate-bits bit-mutation-rate list1)
  264.           (mutate-bits bit-mutation-rate list2)))))
  265.  
  266.  
  267.  
  268. ;************************************************************
  269.  
  270. ;    ONE POINT CROSSOVER
  271.  
  272.  
  273. (defmethod APPLY-OPERATOR ((operator one-point-crossover)
  274.                (population-module basic-population-module))
  275.   "Cross two parents over at a single point to make two children"
  276.   (one-point-crossover (chromosome (get-parent population-module))
  277.                (chromosome (get-parent population-module))))
  278.  
  279.  
  280. ;************************************************************
  281.  
  282. ;    TWO-POINT CROSSOVER
  283.  
  284.  
  285. (defmethod APPLY-OPERATOR ((operator two-point-crossover)
  286.                (population-module basic-population-module))
  287.   "Cross two parents over at two points to make two children"
  288.   (two-point-crossover (chromosome (get-parent population-module))
  289.                (chromosome (get-parent population-module))))
  290.  
  291.  
  292.  
  293. ;************************************************************
  294.  
  295. ;    BINARY MUTATION
  296.  
  297.  
  298. (defmethod APPLY-OPERATOR ((operator binary-mutation)
  299.                (population-module basic-population-module))
  300.   "Mutate bits on a parent to make a child"
  301.   (list (mutate-bits (bit-mutation-rate operator)
  302.              (chromosome (get-parent population-module)))))
  303.  
  304.  
  305. ;************************************************************
  306.  
  307. ;    UNIFORM LIST CROSSOVER
  308.  
  309.  
  310. (defmethod APPLY-OPERATOR ((operator uniform-list-crossover)
  311.                (population-module basic-population-module))
  312.   "Do uniform crossover of elements in two lists of equal length"
  313.   (loop with parent1 = (nreverse (copy-list
  314.                    (chromosome (get-parent population-module))))
  315.     with parent2 = (nreverse (copy-list
  316.                    (chromosome (get-parent population-module))))
  317.     with child1
  318.     with child2
  319.     for element1 in parent1
  320.     for element2 in parent2
  321.     do (if (= 0 (random 2))
  322.            (setf child1 (cons element1 child1)
  323.              child2 (cons element2 child2))
  324.            (setf child1 (cons element2 child1)
  325.              child2 (cons element1 child2)))
  326.     finally (return (list child1 child2))))
  327.  
  328.  
  329. ;************************************************************
  330.  
  331. ;    RANDOM BIT STRING GENERATION
  332.  
  333.  
  334. (defmethod APPLY-OPERATOR ((operator random-bit-string-generation)
  335.                (population-module
  336.                  basic-population-module))
  337.   "Generate a list of random bits"
  338.   (list (create-random-bit-string
  339.       (bit-string-length (representation-technique population-module)))))
  340.  
  341.  
  342.  
  343. ;************************************************************
  344.  
  345. ;    REAL NUMBER MUTATION
  346.  
  347.  
  348.  
  349. (defmethod APPLY-OPERATOR ((operator real-number-mutation)
  350.                (population-module basic-population-module))
  351.   "Replace values of a real-valued chromosome with randomly-chosen
  352.    values according to the spec and the probability"
  353.   (list
  354.     (loop with probability = (mutation-rate operator)
  355.       for field in (copy-list (chromosome (get-parent population-module)))
  356.       for specs = (mutation-specs operator)
  357.             then (if (cdr specs) (cdr specs) specs)
  358.       collect (if (probability-test probability)
  359.               (make-random-value (caar specs) (cadar specs) (caddar specs))
  360.               field))))
  361.  
  362.  
  363.  
  364. ;************************************************************
  365.  
  366. ;    REAL NUMBER CREEP
  367.  
  368.  
  369.  
  370. (defmethod APPLY-OPERATOR ((operator real-number-creep)
  371.                (population-module basic-population-module))
  372.   "Creep elements in a lists of real numbers according to the creep spec"
  373.   (list
  374.     (loop with probability = (creep-rate operator)
  375.       with chromosome = (chromosome (get-parent population-module))
  376.       for field in chromosome
  377.       for specs = (creep-specs operator)
  378.             then (if (cdr specs) (cdr specs) specs)
  379.       collect (if (probability-test probability)
  380.               (creep-value specs field) field))))
  381.  
  382.  
  383.  
  384.  
  385. ;************************************************************
  386.  
  387. ;    AVERAGE CROSSOVER
  388.  
  389.  
  390.  
  391. (defmethod APPLY-OPERATOR ((operator average-crossover)
  392.                (population-module basic-population-module))
  393.   "Average fields in two real-valued parents to make one child"
  394.   (list (let ((chromosome1 (chromosome (get-parent population-module)))
  395.           (chromosome2 (chromosome (get-parent population-module))))
  396.       (loop for field1 in chromosome1 for field2 in chromosome2
  397.         collect (integer-average field1 field2)))))
  398.  
  399.  
  400.  
  401. ;************************************************************
  402.  
  403. ;    AVERAGE REAL CROSSOVER
  404.  
  405.  
  406.  
  407. (defmethod APPLY-OPERATOR ((operator average-real-crossover)
  408.                (population-module basic-population-module))
  409.   "Average fields in two real-valued parents to make one child"
  410.   (list (let ((chromosome1 (chromosome (get-parent population-module)))
  411.           (chromosome2 (chromosome (get-parent population-module))))
  412.       (loop for field1 in chromosome1 for field2 in chromosome2
  413.         collect (/ (+ field1 field2) 2.0)))))
  414.  
  415.  
  416. ;************************************************************
  417.  
  418. ;    UNIFORM ORDER-BASED CROSSOVER
  419.  
  420.  
  421. (defmethod APPLY-OPERATOR ((operator uniform-order-based-crossover)
  422.                (population-module basic-population-module))
  423.   "Cross two parents over using a binary template and re-ordering of some components"
  424.   (let* ((parent1 (chromosome (get-parent population-module)))
  425.      (parent2 (chromosome (get-parent population-module)))
  426.      (template (create-random-bit-string (length parent1)))
  427.      (parent1-scramble-set (get-scramble-set parent1 parent2 template))
  428.      (parent2-scramble-set (get-scramble-set parent2 parent1 template))
  429.      (child1 (template-assemble template parent1 parent1-scramble-set))
  430.      (child2 (template-assemble template parent2 parent2-scramble-set)))
  431.   (list child1 child2)))
  432.  
  433.  
  434.  
  435. ;************************************************************
  436.  
  437. ;    SCRAMBLE SUBLIST MUTATION
  438.  
  439.  
  440. (defmethod APPLY-OPERATOR ((operator SCRAMBLE-SUBLIST-MUTATION)
  441.                (population-module basic-population-module))
  442.   "Return the result of scrambling a sublist of the parent."
  443.   (let ((parent (chromosome (get-parent population-module))))
  444.     (multiple-value-bind (cut-point1 cut-point2)
  445.     (get-two-cut-points (length parent))
  446.       (list (scramble-sublist parent cut-point1 cut-point2)))))
  447.  
  448.  
  449.  
  450. ;************************************************************
  451.  
  452. ;    RANDOM ORDER GENERATION
  453.  
  454.  
  455. (defmethod APPLY-OPERATOR ((operator RANDOM-ORDER-GENERATION)
  456.                (population-module
  457.                  basic-population-module))
  458.   "Return a random permutation of the master list"
  459.   (list (nscramble (copy-list (list-to-permute
  460.                 (initialization-technique population-module))))))
  461.